home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / rw.scm < prev    next >
Text File  |  1995-10-13  |  7KB  |  209 lines
  1. ;;; Basic read and write
  2. ;;; Copyright (c) 1993 by Olin Shivers.
  3.  
  4. ;;; Note: read ops should check to see if their string args are mutable.
  5.  
  6. (define (bogus-substring-spec? s start end)
  7.   (or (< start 0)
  8.       (< (string-length s) end)
  9.       (< end start)))
  10.  
  11.  
  12. ;;; Best-effort/forward-progress reading 
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. (define (generic-read-string!/partial s start end reader source)
  16.   (if (bogus-substring-spec? s start end)
  17.       (error "Bad substring indices" reader source s start end))
  18.  
  19.   (if (= start end) 0 ; Vacuous request.
  20.       (let loop ()
  21.     (receive (err nread) (reader s start end source)
  22.       (if err
  23.           (case err
  24.         ((errno/intr) (loop))
  25.         ((errno/wouldblock errno/again) 0) ; No forward-progess here.
  26.         (else (errno-error err reader
  27.                    s start start end source)))
  28.           (and (not (zero? nread)) nread))))))
  29.  
  30. (define (read-string!/partial s . maybe-args)
  31.   (receive (fd/port start end)
  32.        (parse-optionals maybe-args
  33.                 (current-input-port) 0 (string-length s))
  34.     (cond ((integer? fd/port)
  35.        (generic-read-string!/partial s start end
  36.                      read-fdes-substring!/errno fd/port))
  37.       ((fdport? fd/port)
  38.        (generic-read-string!/partial s start end
  39.                      read-fdport*-substring!/errno 
  40.                      (extensible-port-local-data fd/port)))
  41.  
  42.       (else ; Hack it for base S48 ports
  43.        ;; This case is a little gross in order to get 
  44.        ;; the forward-progress guarantee and handle non-blocking i/o.
  45.        ;; Unix sux. So do low-level Scheme looping constructs.
  46.        (if (>= start end) 0
  47.            (let lp ((i start))
  48.          (let ((c (with-errno-handler
  49.                   ((err data) ((errno/wouldblock errno/again) #f))
  50.                 (read-char fd/port))))
  51.            (cond ((not c) (- i start)) ; non-blocking i/o bailout
  52.              ((eof-object? c)
  53.               (let ((nread (- i start)))
  54.                 (and (not (zero? nread)) nread)))
  55.              (else
  56.               (string-set! s i c)
  57.               (let ((i (+ i 1)))
  58.                 (if (or (= i end) (not (char-ready? fd/port)))
  59.                 (- i start)
  60.                 (lp i))))))))))))
  61.  
  62. (define (read-string/partial len . maybe-fd/port) 
  63.   (let* ((s (make-string len))
  64.      (fd/port (optional-arg maybe-fd/port (current-input-port)))
  65.      (nread (read-string!/partial s fd/port 0 len)))
  66.     (cond ((not nread) #f) ; EOF
  67.       ((= nread len) s)
  68.       (else (substring s 0 nread)))))
  69.  
  70.  
  71. ;;; Persistent reading
  72. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73.  
  74. (define (generic-read-string! s start end reader source)
  75.   (if (bogus-substring-spec? s start end)
  76.       (error "Bad substring indices" reader source s start end))
  77.  
  78.   (let loop ((i start))
  79.     (if (>= i end) (- i start)
  80.     (receive (err nread) (reader s i end source)
  81.       (cond (err (if (= err errno/intr) (loop i)
  82.              ;; Give info on partially-read data in error packet.
  83.              (errno-error err reader
  84.                       s start i end source)))
  85.  
  86.         ((zero? nread) ; EOF
  87.          (let ((result (- i start)))
  88.            (and (not (zero? result)) result)))
  89.  
  90.         (else (loop (+ i nread))))))))
  91.  
  92. (define (read-string! s . maybe-args)
  93.   (receive (fd/port start end)
  94.        (parse-optionals maybe-args
  95.                 (current-input-port) 0 (string-length s))
  96.     (cond ((integer? fd/port)
  97.        (generic-read-string! s start end
  98.                  read-fdes-substring!/errno fd/port))
  99.  
  100.       ((fdport? fd/port)
  101.        (generic-read-string! s start end
  102.                  read-fdport*-substring!/errno
  103.                  (extensible-port-local-data fd/port)))
  104.  
  105.       (else ; Hack it
  106.        (let lp ((i start (+ i 1)))
  107.          (if (= i end) (- end start)
  108.          (let ((c (read-char fd/port)))
  109.            (if (eof-object? c)
  110.                (let ((nread (- i start)))
  111.              (and (not (zero? nread)) nread))
  112.                (begin (string-set! s i c)
  113.                   (lp (+ i 1)))))))))))
  114.  
  115. (define (read-string len . maybe-fd/port) 
  116.   (let* ((s (make-string len))
  117.      (fd/port (optional-arg maybe-fd/port (current-input-port)))
  118.      (nread (read-string! s fd/port 0 len)))
  119.     (cond ((not nread) #f) ; EOF
  120.       ((= nread len) s)
  121.       (else (substring s 0 nread)))))
  122.  
  123.  
  124. ;;; Best-effort/forward-progress writing
  125. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  126. ;;; Non-blocking output to a buffered port is not defined.
  127.  
  128. (define (generic-write-string/partial s start end writer target)
  129.   (if (bogus-substring-spec? s start end)
  130.       (error "Bad substring indices" writer s start end target))
  131.  
  132.   (if (= start end) 0            ; Vacuous request.
  133.       (let loop ()
  134.     (receive (err nwritten) (writer s start end target)
  135.       (if err
  136.           (case err
  137.         ((errno/intr) (loop))
  138.         ((errno/again errno/wouldblock) 0)
  139.         (else (errno-error err writer
  140.                    s start start end target)))
  141.           nwritten)))))
  142.  
  143. (define (write-string/partial s . maybe-args)
  144.   (receive (fd/port start end)
  145.        (parse-optionals maybe-args
  146.                 (current-output-port) 0 (string-length s))
  147.     (cond ((integer? fd/port)
  148.        (generic-write-string/partial s start end
  149.                      write-fdes-substring/errno fd/port))
  150.       ((fdport? fd/port)
  151.        (generic-write-string/partial s start end
  152.                      write-fdport*-substring/errno
  153.                      (extensible-port-local-data fd/port)))
  154.       (else (display (substring s start end) fd/port))))) ; hack
  155.  
  156.  
  157. ;;; Persistent writing
  158. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  159.  
  160. (define (generic-write-string s start end writer target)
  161.   (if (bogus-substring-spec? s start end)
  162.       (error "Bad substring indices" writer s start end target))
  163.  
  164.   (let loop ((i start))
  165.     (if (< i end)
  166.     (receive (err nwritten) (writer s i end target)
  167.       (if err
  168.           (case err
  169.         ((errno/intr) (loop i))
  170.         (else (errno-error err writer
  171.                    s start i end target)))
  172.           (loop (+ i nwritten)))))))
  173.  
  174. (define (write-string s . maybe-args)
  175.   (receive (fd/port start end)
  176.        (parse-optionals maybe-args
  177.                 (current-output-port) 0 (string-length s))
  178.     (cond ((integer? fd/port)
  179.        (generic-write-string s start end
  180.                  write-fdes-substring/errno fd/port))
  181.       ((fdport? fd/port)
  182.        (generic-write-string s start end
  183.                  write-fdport*-substring/errno
  184.                  (extensible-port-local-data fd/port)))
  185.  
  186.       (else (display (substring s start end) fd/port))))) ; hack
  187.  
  188. (define (y-or-n? question . maybe-eof-value)
  189.   (let loop ((count *y-or-n-eof-count*))
  190.     (display question)
  191.     (display " (y/n)? ")
  192.     (let ((line (read-line)))
  193.       (cond ((eof-object? line)
  194.          (newline)
  195.          (if (= count 0)
  196.          (optional-arg* maybe-eof-value
  197.                 (lambda () (error "EOF in y-or-n?")))
  198.          (begin (display "I'll only ask another ")
  199.             (write count)
  200.             (display " times.")
  201.             (newline)
  202.             (loop (- count 1)))))
  203.         ((< (string-length line) 1) (loop count))
  204.         ((char=? (string-ref line 0) #\y) #t)
  205.         ((char=? (string-ref line 0) #\n) #f)
  206.         (else (loop count))))))
  207.  
  208. (define *y-or-n-eof-count* 100)
  209.